home *** CD-ROM | disk | FTP | other *** search
/ ASME's Mechanical Engine…ing Toolkit 1997 December / ASME's Mechanical Engineering Toolkit 1997 December.iso / fortran / for77win.lzh / DEMO.FOR < prev    next >
Text File  |  1987-11-15  |  7KB  |  309 lines
  1.       character*1 i1
  2. c
  3. c initiate window routines
  4. c
  5.       call winit(2,imode)
  6. c
  7. c  hide cursor
  8. c
  9.       call hidcur
  10. c
  11. c make window
  12. c
  13.       call mkwind(1,1,21,6,#1e,1,#1f)
  14. c
  15. c move window diagonaly from top left to bottom right
  16. c
  17.       do 10 i=2,20
  18.       ii=i*3
  19.       call movwin(ii,i)
  20.       call sound(100,1)
  21.       call wait
  22. 10    continue
  23. c
  24. c move window horizontally to the left bottom corner
  25. c
  26.       do 30 i=58,1,-3
  27.       call movwin(i,20)
  28.       call sound(100,1)
  29.       call wait
  30. 30    continue
  31. c
  32. c move window diagonally to top right corner
  33. c
  34.       do 20 i=2,20
  35.       ii=i*3
  36.       jj=21-i
  37.       call movwin(ii,jj)
  38.       call sound(100,1)
  39.       call wait
  40. 20    continue
  41. c
  42. c move window horizontally to its original position
  43. c
  44.       do 40 i=58,1,-3
  45.       call movwin(i,1)
  46.       call sound(100,1)
  47.       call wait
  48. 40    continue
  49.       call waitl
  50. c
  51. c now close window
  52. c
  53.       call clwind
  54. c
  55. c  gradually clear screen
  56. c
  57.       do 50 i=1,20
  58.       j=20+i*3
  59.       k=5+i
  60.       call wincls(1,1,j,k,#57)
  61.       call wait
  62. 50    continue
  63.       call waitl
  64.       call sound(200,5)
  65. c
  66. c  open a new window
  67. c
  68.       call mkwind(20,8,40,11,#1f,1,#1e)
  69. c
  70. c  display the following Welcom message
  71. c
  72.       call wprnst(16,3,'WELCOME',7,29+128)
  73.       call wprnst(18,5,'T O',3,0)
  74.       call wprnst(10,7,'WINDOWS FOR FORTRAN',19,27)
  75.       call waitl
  76.       call wprnst(7,9,'Press any key to Continue',25,#17)
  77. c
  78. c  wait for a key
  79. c
  80.       call getkey(i1,i2)
  81. c
  82. c  close window
  83. c
  84.       call clwind
  85. c
  86. c  make a new window and display more info.
  87. c
  88.       call mkwind(5,2,72,21,#31,2,#3f)
  89.       call wprnst(7,2,'This Demo Will find the root of the equation',
  90.      *44,0)
  91.       call wprnst(25,3,'F(X)=COS(X)-X=0',15,59)
  92.       call wprnst(7,4,'It asks you to enter two values',21,0)
  93.       call wprnst(28,5,'X1 and X2',9,59)
  94.       call wprnst(7,6,'such that',9,0)
  95.       call wprnst(27,7,'F(X1) < 0.0',11,59)
  96.       call wprnst(27,8,'F(X2) > 0.0',11,59)
  97.       call wprnst(7,9,'or vice versa',13,0)
  98.       call wprnst(7,10,'It will iterativly calculate the root and you wi
  99.      *ll be able',58,0)
  100.       call wprnst(7,11,'to WATCH the computer doing his work.',37,0)
  101.       call wprnst(7,13,'Notice that this set of library routines does as
  102.      *sume that',57,62)
  103.       call wprnst(7,14,'humans make mistakes so it will not terminate if
  104.      * you make',57,62)
  105.       call wprnst(7,15,'one while you enter these value',31,62)
  106.       call wprnst(7,16,'EXPERIMENT this feature and',27,62)
  107.       call wprnst(23,18,'HAPPY COMPUTING....',19,63)
  108.       call wprnst(23,20,'Press any key to Continue',25,#37)
  109. c
  110. c  wait for a key to continue
  111. c
  112.       call getkey(i1,i2)
  113. c
  114. c  gradually scroll window up
  115. c
  116.       do 123 iii=1,19
  117.       call wscrup(1)
  118.       call wait
  119. 123   continue
  120.       call getkey(i1,i2)
  121. c
  122. c  close window
  123. c
  124.       call clwind
  125. c
  126. c  clear screen with blue back ground
  127. c
  128.       call cls(#17)
  129. c
  130. c  call demo subroutine
  131. c
  132.       call demo
  133. c
  134. c  clear screen then exit
  135. c
  136.       call cls(07)
  137. c
  138. c  show cursor
  139. c
  140.       call shwcur
  141.       end
  142.  
  143.       subroutine demo
  144.       character*1 txt*80,i1
  145.       data error /1.e-6/
  146.  
  147. c
  148. c  peeb
  149. c
  150.       call sound(300,5)
  151. c
  152. c  make display window
  153. c
  154.       call mkwind(20,6,40,14,75,2,67)
  155. c
  156. c  print title and info
  157. c
  158.       call wprnst(17,1,'DEMO',4,128+75)
  159.       call wprnst(10,2,'ROOT CALCULATION OF',19,0)
  160.       call wprnst(13,3,'F(X)=COS(X)-X',13,79)
  161.       call wprnst(5,6,'X1=',3,0)
  162.       call wprnst(5,8,'X2=',3,0)
  163.       call wprnst(21,6,'F(X1)=',6,0)
  164.       call wprnst(21,8,'F(X2)=',6,0)
  165. c
  166. c   show cursor to aide in entering data
  167. c
  168.       call shwcur
  169. c
  170. c  read a real variable x1 then x2
  171. c
  172. 22    call wreadr(10,6,x1,10,52)
  173.       call wreadr(10,8,x2,10,52)
  174. c
  175. c  calculate cos(x1) & cos(x2)
  176.       y11=cos(x1)
  177.       y1=y11-x1
  178.       y22=cos(x2)
  179.       y2=y22-x2
  180.       y=y1*y2
  181. c
  182. c  if x1 & x2 does not satisfy the requirements display error message
  183. c  and prompt for new values
  184. c
  185.       if(y.gt.0) then
  186.         call sound(40,10)
  187.         call mkwind(10,10,60,6,113,2,0)
  188.         call wprnst(27,1,'ERROR',5,0)
  189.         call wprnst(19,2,'DATA IS NOT ACCEPTABLE',22,0)
  190.         call wprnst(26,3,'TRY AGAIN',9,0)
  191.         call wprnst(23,5,'Press any key',13,123)
  192.         call getkey(i1,i2)
  193.         call clwind
  194.         goto 22
  195.       endif
  196. c
  197. c  hid cursor again
  198. c
  199.       call hidcur
  200. c
  201. c  else continue
  202. c
  203. 55    x=(x1+x2)/2.
  204.       yy=cos(x)
  205.       y=yy-x
  206.       y3=y1*y
  207.       if(y3.le.0) then
  208.         x2=x
  209.         y22=yy
  210.         y2=y
  211.       else
  212.         x1=x
  213.         y1=y
  214.         y11=yy
  215.       endif
  216. c
  217. c  use fortran write statement to generate a string to display
  218. c
  219.       write(txt,2)x1
  220. 2     format(1x,f9.7)
  221.       call wprnstr(10,6,txt,10,52)
  222.       write(txt,2)x2
  223.       call wprnstr(10,8,txt,10,52)
  224.       write(txt,2)y1
  225.       call wprnstr(27,6,txt,10,52)
  226.       write(txt,2)y2
  227.       call wprnstr(27,8,txt,10,52)
  228.       call sound(150,1)
  229.       call waitl
  230. c
  231. c  if y withen accepted error limit then stop calculations and display
  232. c  answer
  233. c
  234.       if(abs(y).le.error) then
  235.         write(txt,1)x
  236.  1      format(1x,'ROOT IS ',E12.5)
  237.         call wprnst(10,10,txt,21,75)
  238.         call wprnst(13,12,'Press any key',13,0)
  239.         call getkey(i1,i2)
  240.         call clwind
  241.         return
  242.       endif
  243. c
  244. c  else continue
  245. c
  246.       goto 55
  247.       end
  248.  
  249.  
  250.  
  251.  
  252.  
  253.  
  254.       subroutine wait
  255. c
  256. c  this subroutine does nothing it only slows down the program
  257. c
  258.       do 10 i=1,5000
  259.       j=i
  260. 10    continue
  261.       return
  262.       end
  263.  
  264.  
  265.       subroutine waitl
  266. c
  267. c  this subroutine does nothing it only slows down the program
  268. c
  269.       do 10 i=1,30000
  270.       j=i
  271. 10    continue
  272.       return
  273.       end
  274.  
  275.       subroutine wincls(i,j,id,jd,ia)
  276.       common /tareq1/n,iacces
  277. c
  278. c  This subroutine gives you some idea of what can be done using the
  279. c  low level tools used to wite this library
  280. c
  281.       if (iacces.eq.0) then
  282. c
  283. c  if iacces = 0 then you use bios calls
  284. c
  285.         i2=i+id-1
  286.         j2=j+jd-1
  287.         call bwindw(i,j,i2,j2,ia)
  288. c
  289. c  bwindw uses the bios to fill a window with coordinates
  290. c  i,j  and i2,j2 with blanks having attribute ia
  291. c
  292.       else
  293. c
  294. c  dwindw does the same thing except it does it by writing directly
  295. c  to display memory which result in a faster results
  296. c
  297. c  Notice that the arguments are different now
  298. c  i,j:  the upper left corner of window
  299. c  id :  # of columns
  300. c  jd :  # of rows
  301. c
  302.         call dwindw(i,j,id,jd,ia)
  303.  
  304.       endif
  305.       return
  306.       end
  307.  
  308.  
  309.